MacTech 1 to 12/MacTech-vol-1-12.toast/Source/MacTech® Magazine/Volume 07 - 1991/07.03 Mar 91/PICS Code/PICS Player Source

Text File | 1990-12-05 | 3.7 KB | 179 lines | [TEXT/AOqc]

{    PICS Player    -    Steve Sheets}
{}
{    This Progam displays a PICS animation sequence.  It loads PICS files,}
{    animates the file once or animates it in a continous loop.  Either}
{    animation can be canceled by pressing any key.  The program uses}
{    alerts to prompt the user for actions.  The actual animation is drawn}
{    in a window the size of the screen.}

program PICSplayer;

    uses
        PICSUnit;

    const
        kLoadQuit = 500;
        kPICSinfo = 501;
        kError = 502;
        kColorProblem = 503;

    var
        gDone, gColorFlag: BOOLEAN;
        gName: Str255;
        gNum: INTEGER;
        gPICS: TPICSHdl;
        gWindow: WindowPtr;

    procedure SetUp;
        const
            ROM85Loc = $28E;
            TwoHighMask = $C000;
        type
            WordPtr = ^INTEGER;
        var
            tempWordPtr: WordPtr;
    begin
        tempWordPtr := POINTER(ROM85Loc);
        gColorFlag := (BitAnd(tempWordPtr^, TwoHighMask) = 0);
        gDone := FALSE;
        gName := '';
        gPICS := nil;
        if gColorFlag then
            gWindow := NewCWindow(nil, Screenbits.Bounds, '', TRUE, dBoxProc, POINTER(-1), FALSE, 0)
        else
            gWindow := NewWindow(nil, Screenbits.Bounds, '', TRUE, dBoxProc, POINTER(-1), FALSE, 0);
        if gWindow <> nil then
            begin
                SetPort(gWindow);
                EraseRect(screenbits.bounds);
            end;
        SetCursor(Arrow);
    end;

    procedure ShutDown;
    begin
        if gPICS <> nil then
            begin
                DisposePICS(gPICS);
                gPICS := nil;
            end;
        if gWindow <> nil then
            begin
                DisposeWindow(gWindow);
                gWindow := nil;
            end;
    end;

    procedure PlayPICS (Loop: BOOLEAN);
        var
            tempH, tempV: INTEGER;
    begin
        if gPICS <> nil then
            begin
                SelectWindow(gWindow);
                SetPort(gWindow);

                EraseRect(screenbits.bounds);
                with screenbits.bounds, gPICS^^ do
                    begin
                        tempH := (right - left - DimH) div 2;
                        tempV := (bottom - top - DimV) div 2;
                        if tempH < 0 then
                            tempH := 0;
                        if tempV < 0 then
                            tempV := 0;
                    end;

                HideCursor;
                DrawPICS(gPICS, tempH, tempV, Loop, TRUE);
                ShowCursor;

                EraseRect(screenbits.bounds);
            end;
    end;

    procedure LoadPICS;
        var
            tempList: SFTypeList;
            tempPt: Point;
            tempE: OSErr;
            tempStr: Str255;
            tempNum: INTEGER;
            tempReply: SFReply;
    begin
        if gPICS <> nil then
            begin
                DisposePICS(gPICS);
                gPICS := nil;
            end;

        tempPt.v := 40;
        tempPt.h := 40;
        tempList[0] := kPICStype;
        SFGetFile(tempPt, '', nil, 1, tempList, nil, tempReply);
        if tempReply.good then
            begin
                gName := tempReply.fname;
                tempE := ReadPICS(gName, tempReply.vRefNum, gPICS);
                if tempE <> noErr then
                    begin
                        case tempE of
                            memFullErr:
                                tempStr := 'Memmory full error.  The file you are reading is to large';
                            fnfErr:
                                tempStr := 'File not found error';
                            resNotFound:
                                tempStr := 'A required resource was not found in the file';
                            otherwise
                                begin
                                    NumToString(tempE, tempStr);
                                    tempStr := CONCAT('Error Number: ', tempStr);
                                end
                        end;
                        ParamText(gName, tempStr, '', '');
                        tempNum := Alert(kError, nil);
                    end
                else if (not gColorFlag) and (gPICS <> nil) then
                    if (gPICS^^.PICSInfoHdl <> nil) then
                        if (gPICS^^.PICSInfoHdl^^.BWColor = 1) then
                            begin
                                ParamText(gName, '', '', '');
                                tempNum := Alert(kColorProblem, nil);
                            end;
            end;
    end;

    procedure DoInformationAlert;
        var
            tempStr: Str255;
    begin
        NumToString(gPICS^^.NumFrames, tempStr);
        ParamText(gName, tempStr, '', '');
        gNum := Alert(kPICSinfo, nil);
    end;

begin
    SetUp;

    if gWindow <> nil then
        repeat
            if gPICS = nil then
                gNum := Alert(kLoadQuit, nil)
            else
                DoInformationAlert;

            case gNum of
                1:
                    PlayPICS(FALSE);
                2:
                    LoadPICS;
                3:
                    gDone := TRUE;
                4:
                    PlayPICS(TRUE);
                otherwise
            end;
        until gDone;

    ShutDown;
end.